home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / borland / bgiherc.zip / BGIDEMO.PAS < prev    next >
Pascal/Delphi Source File  |  1989-05-31  |  41KB  |  1,436 lines
  1.  
  2. { Copyright (c) 1985, 88 by Borland International, Inc. }
  3.  
  4. program BGIDemo;
  5. (*
  6.   Turbo Pascal 5.0 Borland Graphics Interface (BGI) demonstration
  7.   program. This program shows how to use many features of the Graph unit.
  8.  
  9.   Modified 2/21/89 to support the Hercules InColor Card using the Hercules
  10.   supplied HERC.BGI driver.  Note that HERCULES.TPU is also used to provide
  11.   the reset procedures LoadHFNT and LoadHPAL.  If you don't have HERCULES.TPU,
  12.   remove this reference from the "uses" section, and remove the LoadHFNT and
  13.   LoadHPAL statements from the code.
  14. *)
  15.  
  16. uses
  17.   Crt, Dos, Graph, Hercules;
  18.  
  19. const
  20.   { The five fonts available }
  21.   Fonts : array[0..4] of string[13] =
  22.   ('DefaultFont', 'TriplexFont', 'SmallFont', 'SansSerifFont', 'GothicFont');
  23.  
  24.   { The five predefined line styles supported }
  25.   LineStyles : array[0..4] of string[9] =
  26.   ('SolidLn', 'DottedLn', 'CenterLn', 'DashedLn', 'UserBitLn');
  27.  
  28.   { The twelve predefined fill styles supported }
  29.   FillStyles : array[0..11] of string[14] =
  30.   ('EmptyFill', 'SolidFill', 'LineFill', 'LtSlashFill', 'SlashFill',
  31.    'BkSlashFill', 'LtBkSlashFill', 'HatchFill', 'XHatchFill',
  32.    'InterleaveFill', 'WideDotFill', 'CloseDotFill');
  33.  
  34.   { The two text directions available }
  35.   TextDirect : array[0..1] of string[8] = ('HorizDir', 'VertDir');
  36.  
  37.   { The Horizontal text justifications available }
  38.   HorizJust  : array[0..2] of string[10] = ('LeftText', 'CenterText', 'RightText');
  39.  
  40.   { The vertical text justifications available }
  41.   VertJust   : array[0..2] of string[10] = ('BottomText', 'CenterText', 'TopText');
  42.  
  43. var
  44.   GraphDriver : integer;  { The Graphics device driver }
  45.   GraphMode   : integer;  { The Graphics mode value }
  46.   MaxX, MaxY  : word;     { The maximum resolution of the screen }
  47.   ErrorCode   : integer;  { Reports any graphics errors }
  48.   MaxColor    : word;     { The maximum color value available }
  49.   OldExitProc : Pointer;  { Saves exit procedure address }
  50.  
  51. {$F+}
  52. procedure MyExitProc;
  53. begin
  54.   ExitProc := OldExitProc; { Restore exit procedure address }
  55.   CloseGraph;              { Shut down the graphics system }
  56. end; { MyExitProc }
  57. {$F-}
  58.  
  59. procedure Initialize;
  60. { Initialize graphics and report any errors that may occur }
  61. var
  62.   InGraphicsMode : boolean; { Flags initialization of graphics mode }
  63.   PathToDriver   : string;  { Stores the DOS path to *.BGI & *.CHR }
  64. begin
  65.   { when using Crt and graphics, turn off Crt's memory-mapped writes }
  66.   DirectVideo := False;
  67.   OldExitProc := ExitProc;                { save previous exit proc }
  68.   ExitProc := @MyExitProc;                { insert our exit proc in chain }
  69.   PathToDriver := '';
  70.   repeat
  71.  
  72. {$IFDEF Use8514}                          { check for Use8514 $DEFINE }
  73.     GraphDriver := IBM8514;
  74.     GraphMode := IBM8514Hi;
  75. {$ELSE}
  76. (*    GraphDriver := DETECT;                { use autodetection }  *)
  77.     GraphDriver := HERCMONO;              {  If the Hercules card is not     }
  78. {$ENDIF}                                  {  the ONLY adapter in the system  }
  79.                                           {  the BGI autodetect function may }
  80.                                           {  fail.  To accommodate the case  }
  81.                                           {  of the Hercules InColor Card    }
  82.                                           {  alongside the Hercules VGA Card }
  83.                                           {  this code forces the driver     }
  84.                                           {  to Hercules.                    }
  85.  
  86.     InitGraph(GraphDriver, GraphMode, PathToDriver);
  87.     ErrorCode := GraphResult;             { preserve error return }
  88.     if ErrorCode <> grOK then             { error? }
  89.     begin
  90.       Writeln('Graphics error: ', GraphErrorMsg(ErrorCode));
  91.       if ErrorCode = grFileNotFound then  { Can't find driver file }
  92.       begin
  93.         Writeln('Enter full path to BGI driver or type <Ctrl-Break> to quit:');
  94.         Readln(PathToDriver);
  95.         Writeln;
  96.       end
  97.       else
  98.         Halt(1);                          { Some other error: terminate }
  99.     end;
  100.   until ErrorCode = grOK;
  101.   Randomize;                { init random number generator }
  102.   MaxColor := GetMaxColor;  { Get the maximum allowable drawing color }
  103.   MaxX := GetMaxX;          { Get screen resolution values }
  104.   MaxY := GetMaxY;
  105. end; { Initialize }
  106.  
  107. function Int2Str(L : LongInt) : string;
  108. { Converts an integer to a string for use with OutText, OutTextXY }
  109. var
  110.   S : string;
  111. begin
  112.   Str(L, S);
  113.   Int2Str := S;
  114. end; { Int2Str }
  115.  
  116. function RandColor : word;
  117. { Returns a Random non-zero color value that is within the legal
  118.   color range for the selected device driver and graphics mode.
  119.   MaxColor is set to GetMaxColor by Initialize }
  120. begin
  121.   RandColor := Random(MaxColor)+1;
  122. end; { RandColor }
  123.  
  124. procedure DefaultColors;
  125. { Select the maximum color in the Palette for the drawing color }
  126. begin
  127.   SetColor(MaxColor);
  128. end; { DefaultColors }
  129.  
  130. procedure DrawBorder;
  131. { Draw a border around the current view port }
  132. var
  133.   ViewPort : ViewPortType;
  134. begin
  135.   DefaultColors;
  136.   SetLineStyle(SolidLn, 0, NormWidth);
  137.   GetViewSettings(ViewPort);
  138.   with ViewPort do
  139.     Rectangle(0, 0, x2-x1, y2-y1);
  140. end; { DrawBorder }
  141.  
  142. procedure FullPort;
  143. { Set the view port to the entire screen }
  144. begin
  145.   SetViewPort(0, 0, MaxX, MaxY, ClipOn);
  146. end; { FullPort }
  147.  
  148. procedure MainWindow(Header : string);
  149. { Make a default window and view port for demos }
  150. begin
  151.   DefaultColors;                           { Reset the colors }
  152.   ClearDevice;                             { Clear the screen }
  153.   SetTextStyle(DefaultFont, HorizDir, 1);  { Default text font }
  154.   SetTextJustify(CenterText, TopText);     { Left justify text }
  155.   FullPort;                                { Full screen view port }
  156.   OutTextXY(MaxX div 2, 2, Header);        { Draw the header }
  157.   { Draw main window }
  158.   SetViewPort(0, TextHeight('M')+4, MaxX, MaxY-(TextHeight('M')+4), ClipOn);
  159.   DrawBorder;                              { Put a border around it }
  160.   { Move the edges in 1 pixel on all sides so border isn't in the view port }
  161.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  162. end; { MainWindow }
  163.  
  164. procedure StatusLine(Msg : string);
  165. { Display a status line at the bottom of the screen }
  166. begin
  167.   FullPort;
  168.   DefaultColors;
  169.   SetTextStyle(DefaultFont, HorizDir, 1);
  170.   SetTextJustify(CenterText, TopText);
  171.   SetLineStyle(SolidLn, 0, NormWidth);
  172.   SetFillStyle(EmptyFill, 0);
  173.   Bar(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);      { Erase old status line }
  174.   Rectangle(0, MaxY-(TextHeight('M')+4), MaxX, MaxY);
  175.   OutTextXY(MaxX div 2, MaxY-(TextHeight('M')+2), Msg);
  176.   { Go back to the main window }
  177.   SetViewPort(1, TextHeight('M')+5, MaxX-1, MaxY-(TextHeight('M')+5), ClipOn);
  178. end; { StatusLine }
  179.  
  180. procedure WaitToGo;
  181. { Wait for the user to abort the program or continue }
  182. const
  183.   Esc = #27;
  184. var
  185.   Ch : char;
  186. begin
  187.   StatusLine('Esc aborts or press a key...');
  188.   repeat until KeyPressed;
  189.   Ch := ReadKey;
  190.   if ch = #0 then ch := readkey;      { trap function keys }
  191.   if Ch = Esc then
  192.   begin
  193.     LoadHFNT;
  194.     LoadHPAL;
  195.     Halt(0);                           { terminate program }
  196.   end
  197.   else
  198.     ClearDevice;                      { clear screen, go on with demo }
  199. end; { WaitToGo }
  200.  
  201. procedure GetDriverAndMode(var DriveStr, ModeStr : string);
  202. { Return strings describing the current device driver and graphics mode
  203.   for display of status report }
  204. begin
  205.   DriveStr := GetDriverName;
  206.   ModeStr := GetModeName(GetGraphMode);
  207. end; { GetDriverAndMode }
  208.  
  209. procedure ReportStatus;
  210. { Display the status of all query functions after InitGraph }
  211. const
  212.   X = 10;
  213. var
  214.   ViewInfo   : ViewPortType;     { Parameters for inquiry procedures }
  215.   LineInfo   : LineSettingsType;
  216.   FillInfo   : FillSettingsType;
  217.   TextInfo   : TextSettingsType;
  218.   Palette    : PaletteType;
  219.   DriverStr  : string;           { Driver and mode strings }
  220.   ModeStr    : string;
  221.   Y          : word;
  222.  
  223. procedure WriteOut(S : string);
  224. { Write out a string and increment to next line }
  225. begin
  226.   OutTextXY(X, Y, S);